home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / devtes2 / devtest2.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1995-05-08  |  5.3 KB  |  137 lines
  1. VERSION 2.00
  2. Begin Form DevForm 
  3.    Caption         =   "Device Tester"
  4.    ClientHeight    =   4080
  5.    ClientLeft      =   1095
  6.    ClientTop       =   1485
  7.    ClientWidth     =   7365
  8.    Height          =   4485
  9.    Left            =   1035
  10.    LinkTopic       =   "Form1"
  11.    ScaleHeight     =   4080
  12.    ScaleWidth      =   7365
  13.    Top             =   1140
  14.    Width           =   7485
  15.    Begin CommandButton Command1 
  16.       Caption         =   "&Set as Default"
  17.       Height          =   375
  18.       Left            =   600
  19.       TabIndex        =   3
  20.       Top             =   3000
  21.       Width           =   1815
  22.    End
  23.    Begin ListBox List1 
  24.       Height          =   2565
  25.       Left            =   600
  26.       TabIndex        =   0
  27.       Top             =   240
  28.       Width           =   5175
  29.    End
  30.    Begin Label Label2 
  31.       AutoSize        =   -1  'True
  32.       Height          =   195
  33.       Left            =   1440
  34.       TabIndex        =   2
  35.       Top             =   3600
  36.       Width           =   75
  37.    End
  38.    Begin Label Label1 
  39.       Caption         =   "Default:"
  40.       Height          =   255
  41.       Left            =   600
  42.       TabIndex        =   1
  43.       Top             =   3600
  44.       Width           =   735
  45.    End
  46. DefInt A-Z
  47. ' Windows API Functions
  48. Declare Function GetProfileString Lib "Kernel" (ByVal AppName$, ByVal KeyName As Any, ByVal Default$, ByVal ReturnedString$, ByVal nSize%)
  49. Declare Function WriteProfileString Lib "Kernel" (ByVal AppName$, ByVal KeyName$, ByVal lpString$)
  50. Declare Function PostMessageByString Lib "User" Alias "PostMessage" (ByVal hWnd%, ByVal wMsg%, ByVal wParam%, ByVal lParam$)
  51. ' Windows API Constants
  52. Const HWND_BROADCAST = &HFFFF
  53. Const WM_WININICHANGE = &H1A
  54. ' Device Arrays
  55. Dim DeviceInfo$()
  56. Dim DeviceList$()
  57. Dim DeviceName$()
  58. Sub Command1_Click ()
  59.     ' Call sub to set new Default Device
  60.     SetNewDefault
  61.     ' Call sub to Get Default Device
  62.     GetDefault
  63. End Sub
  64. Sub Form_Load ()
  65.     ' Call sub to Get Default Device
  66.     GetDefault
  67.     ' Call sub to Get Device List
  68.     GetDevices
  69.     ' Start with First Item on List
  70.     List1.ListIndex = 0
  71. End Sub
  72. Sub Form_Resize ()
  73.     ' Call sub to Get Default Device
  74.     GetDefault
  75. End Sub
  76. Sub GetDefault ()
  77.     'Determine Default Device
  78.     Section$ = "windows"
  79.     Key$ = "device"
  80.     RetVal$ = String$(255, 0)
  81.     ErrCode = GetProfileString(Section$, Key$, "", RetVal$, Len(RetVal$))
  82.     RetVal$ = Left$(RetVal$, InStr(RetVal$, Chr$(0)) - 1)
  83.     Label2.Caption = Left$(RetVal$, InStr(RetVal$, ",") - 1) + " on " + Mid$(Mid$(RetVal$, InStr(RetVal$, ",") + 1), InStr(Mid$(RetVal$, InStr(RetVal$, ",") + 1), ",") + 1)
  84. End Sub
  85. Sub GetDevices ()
  86.     ' Find Devices Installed
  87.     DeviceCount = 0
  88.     Section$ = "devices"
  89.     Key$ = ""
  90.     RetVal$ = String$(4096, 0)
  91.     ErrCode = GetProfileString(Section$, 0&, "", RetVal$, Len(RetVal$))
  92.     LastNull = 0
  93.     If ErrCode <> 0 Then
  94.         Do
  95.             
  96.             ' Get Device's name as seen by user
  97.             NameOfDevice$ = Left$(RetVal$, InStr(RetVal$, Chr$(0)) - 1)
  98.             RetVal$ = Mid$(RetVal$, InStr(RetVal$, Chr$(0)) + 1)
  99.             
  100.             ' Get Device's Internal Name and Connection Information
  101.             ReturnedString$ = String$(255, 0)
  102.             ErrCode = GetProfileString(Section$, NameOfDevice$, "", ReturnedString$, Len(ReturnedString$))
  103.             InternalName$ = Left$(ReturnedString$, InStr(ReturnedString$, ",") - 1)
  104.             ConnectionInfo$ = Mid$(ReturnedString$, InStr(ReturnedString$, ",") + 1)
  105.             ' Parse out connection list and add to ListBox
  106.             Do
  107.                 If InStr(ConnectionInfo$, ",") Then
  108.                     ConnectToAdd$ = Left$(ConnectionInfo$, InStr(ConnectionInfo$, ",") - 1)
  109.                     ConnectionInfo$ = Mid$(ConnectionInfo$, InStr(ConnectionInfo$, ",") + 1)
  110.                     NoMoreToFind = False
  111.                 Else
  112.                     ConnectToAdd$ = Left$(ConnectionInfo$, InStr(ConnectionInfo$, Chr$(0)) - 1)
  113.                     NoMoreToFind = True
  114.                 End If
  115.                 DeviceCount = DeviceCount + 1
  116.                 ReDim Preserve DeviceList$(DeviceCount)
  117.                 DeviceList$(DeviceCount) = NameOfDevice$
  118.                 ReDim Preserve DeviceName$(DeviceCount)
  119.                 DeviceName$(DeviceCount) = InternalName$
  120.                 ReDim Preserve DeviceInfo$(DeviceCount)
  121.                 DeviceInfo$(DeviceCount) = ConnectToAdd$
  122.                 List1.AddItem DeviceList$(DeviceCount) + " on " + DeviceInfo$(DeviceCount)
  123.             Loop Until NoMoreToFind
  124.             LastNull = InStr(RetVal$, Chr$(0))
  125.         Loop Until LastNull = 1         ' 1 indicates that 1st position is a null, no more entries
  126.     End If
  127.     RetVal$ = ""
  128.     ReturnedString$ = ""
  129. End Sub
  130. Sub SetNewDefault ()
  131.     ' Get Name and Full Info of New Default Device from List Box
  132.     NewDevice$ = DeviceList$(List1.ListIndex + 1) + "," + DeviceName$(List1.ListIndex + 1) + "," + DeviceInfo$(List1.ListIndex + 1)
  133.     ' Update Win.INI and send BroadCast changes
  134.     ErrCode = WriteProfileString("windows", "device", NewDevice$)
  135.     ErrCode = PostMessageByString(HWND_BROADCAST, WM_WININICHANGE, 0, "windows")
  136. End Sub
  137.